home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / base.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  7.5 KB  |  220 lines
  1. (herald base)
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define initial-primop-env
  27.   (make-definition-table 'initial-primop-env))
  28.  
  29. (define-local-syntax (define-initial-primop id . clauses)
  30.   `(let ((primop ,(primop-code id '() clauses)))
  31.      (add-primop initial-primop-env primop)
  32.      (set (table-entry primop-table ',id) primop)
  33.      (make-definition-entry (create-variable ',id)
  34.                             initial-primop-env
  35.                             '()
  36.                             'constant
  37.                             (node->vector (create-primop-node primop))
  38.                             nil)))
  39.  
  40. ;;; BASIC PRIMOPS
  41. ;;;============================================================================
  42. ;;; These are all known to alphatize, simplify, etc.
  43.  
  44. ;;; Place marking primops
  45. ;;;============================================================================
  46. ;;; These are used by alpha to mark points in the tree.
  47.  
  48. (define-initial-primop undefined)
  49.  
  50. (define-initial-primop *primop
  51.   ((primop.simplify self node)
  52.    (simplify-*primop self node)))
  53.  
  54. (define-initial-primop undefined-effect
  55.   ((primop.side-effects? self) t)
  56.   ((primop.generate self node)
  57.    (generate-undefined-effect node))
  58.   ((primop.special? self) t)
  59.   ((primop.simplify self node)
  60.    (simplify-undefined-effect node))
  61.   ((primop.type self node)
  62.    '#[type (proc #f (proc #f) string)]))
  63.  
  64. (define-initial-primop Y
  65.   ((primop.generate self node)
  66.    (generate-labels node))
  67.   ((primop.simplify self node)
  68.    (simplify-y node))
  69.   ((primop.side-effects? self) t)
  70.   ((primop.special? self) t))
  71.  
  72. (define-initial-primop conditional
  73.   ((primop.generate self node)
  74.    (primop.generate (primop-value ((call-arg 3) node)) node))
  75.   ((primop.conditional? self) t)
  76.   ((primop.type self node)
  77.    (if (node? node)
  78.        (primop.conditional-type (primop-value ((call-arg 3) node)) node)
  79.        '#[type top]))
  80.   ((primop.simplify self node)
  81.    (primop.simplify (primop-value ((call-arg 3) node)) node)))
  82.  
  83. (define-initial-primop test
  84.   ((primop.generate self node)
  85.    (primop.test-code (primop-value ((call-arg 4) node)) node '#f))
  86.   ((primop.presimplify self node)
  87.    (presimplify-to-conditional node))
  88.   ((primop.simplify self node)
  89.    (simplify-test node))
  90.   ((primop.conditional-type self node)
  91.    (primop.predicate-type (primop-value ((call-arg 4) node)) node))
  92.   ((primop.conditional? self) t))
  93.  
  94. (define-initial-primop true?
  95.   ((primop.test-code self node #f)
  96.    (generate-nil-test node))
  97.   ((primop.presimplify self node)
  98.    (presimplify-predicate node))           
  99.   ((primop.make-closed self)
  100.    (make-closed-predicate self))
  101.   ((primop.jump-on-equal? self) t)       ; because we compare with nil
  102.   ((primop.rep-wants self) type/top)
  103.   ((primop.predicate-type self node)
  104.    '#[type (proc #f (proc #f) (proc #f) top top top)])
  105.   ((primop.type self node)
  106.    '#[type (proc #f (proc #f boolean) top)]))
  107.  
  108. (define-initial-primop *set-var
  109.   ((primop.side-effects? self) t)
  110.   ((primop.generate self node)
  111.    (generate-set node
  112.                  ((call-arg 2) node)
  113.                  ((call-arg 3) node)))
  114.   ((primop.uses-L-value? self) t)
  115.   ((primop.definition? self) t)
  116.   ((primop.definition-variant self) 'set))
  117.  
  118. (define-initial-primop single-set-var
  119.   ((primop.side-effects? self) t)
  120.   ((primop.generate self node)
  121.    (generate-single-set node
  122.                         ((call-arg 2) node)
  123.                         ((call-arg 3) node)))
  124.   ((primop.uses-L-value? self) t))
  125.  
  126. (define-initial-primop *locative
  127.   ((primop.generate self node)
  128.    (generate-locative node))
  129.   ((primop.definition-variant self) 'set)
  130.   ((primop.definition? self) t)
  131.   ((primop.uses-L-value? self) t))
  132.  
  133. ; Defining primops
  134. ;============================================================================
  135. ; These assign values to global variables.
  136.  
  137. (define-initial-primop *define
  138.   ((primop.side-effects? self) t)
  139.   ((primop.generate self node)
  140.    (generate-define-var node))
  141.   ((primop.definition? self) t)
  142.   ((primop.uses-L-value? self) t)
  143.   ((primop.definition-variant self) 'define))
  144.  
  145. (define-initial-primop *lset
  146.   ((primop.side-effects? self) t)
  147.   ((primop.generate self node)
  148.    (generate-define-var node))
  149.   ((primop.definition? self) t)
  150.   ((primop.uses-L-value? self) t)
  151.   ((primop.definition-variant self) 'lset))
  152.  
  153. ;;; To deal with objects and their ilk.
  154. (define-initial-primop proc+handler)
  155.  
  156. (define-initial-primop remove-state-object
  157.   ((primop.side-effects? self) t)
  158.   ((primop.generate self node)
  159.    (generate-remove-state-object node)))
  160.  
  161.  
  162. ;;; The three location primops.  These generate code for locations the same
  163. ;;; way COMPARE does for EQ? etc.
  164. ;;;   (CAR-LOC (LAMBDA (X) (CONTENTS <cont> X) L) =>
  165. ;;;   (CONTENTS-LOCATION <cont> CAR-LOC L)
  166. ;;;
  167. ;;;   (CAR-LOC (LAMBDA (X) (SET-CONTENTS <cont> X A) L) =>
  168. ;;;   (SET-LOCATION <cont> CAR-LOC A L)  ;Value goes before arguments.
  169. ;;;
  170.  
  171. (define-initial-primop contents-location
  172.   ((primop.generate self node)
  173.    (generate-contents-location node))
  174.   ((primop.type self node)
  175.    (if (node? node)
  176.        (primop.contents-type (primop-value ((call-arg 2) node)))
  177.        '#[type top])))
  178.  
  179. (define-initial-primop set-location
  180.   ((primop.side-effects? self) t)
  181.   ((primop.generate self node)
  182.    (generate-set-location node))
  183.   ((primop.type self node)
  184.    (if (node? node)
  185.        (primop.set-type (primop-value ((call-arg 2) node)))
  186.        '#[type top])))
  187.  
  188. (define-initial-primop locative-location)
  189.  
  190. (define-initial-primop make-cell
  191.   ((primop.generate self node)
  192.    (generate-make-cell node))
  193.   ((primop.type self node)
  194.    '#[type (proc #f (proc #f cell) top)]))
  195.  
  196. (define-initial-primop cell-value
  197.   ((primop.location? self) t)
  198.   ((primop.location-specs self) (fx- CELL tag/extend))
  199.   ((primop.rep-wants self) 'rep/pointer)
  200.   ((primop.simplify self node)
  201.    (simplify-location node))
  202.   ((primop.type self node)
  203.    '#[type (proc #f (proc #f top) cell)]))
  204.  
  205. (define-initial-primop lap 
  206.   ((primop.special? self) t)
  207.   ((primop.side-effects? self) t)
  208.   ((primop.generate self node)        
  209.    (clear-slots)   
  210.    (lap-transduce (leaf-value ((call-arg 2) node)))))
  211.  
  212. (define-initial-primop lap-template 
  213.   ((primop.side-effects? self) t)
  214.   ((primop.generate self node)
  215.    (generate-lap-template node)))
  216.  
  217. (define-initial-primop computed-goto
  218.   ((primop.simplify self node)
  219.    (simplify-computed-goto node)))
  220.